home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacHaskell 2.2 / printers / print-ntypes.scm < prev    next >
Encoding:
Text File  |  1994-09-27  |  2.2 KB  |  80 lines  |  [TEXT/CCL2]
  1. ;;; These printers deal with ntype structures.
  2.  
  3. ;;; Too much of this file is copied from print-types!
  4.  
  5. (define-ast-printer ntyvar (object xp)
  6.   (let ((object (prune object)))
  7.     (if (ntyvar? object)
  8.     (begin
  9.       (write-char #\t xp)
  10.       (write (tyvar->number object) xp))
  11.     (write object xp))))
  12.  
  13. ;;; Various type special cases have a magic cookie in the def field.
  14.  
  15. ;;; This unexpands the IO tycon to make type error messages much more
  16. ;;; readable.
  17.  
  18. (define-ast-printer ntycon (object xp)
  19.   (let ((tycon (ntycon-tycon object))
  20.     (args (ntycon-args object)))
  21.     (if (eq? tycon '#f)
  22.     (write-string "<Bogus tycon>" xp)
  23.     (if (and (eq? tycon (core-symbol "Arrow"))
  24.          (ntycon? (car args))
  25.          (eq? (ntycon-tycon (car args)) (core-symbol "SystemState_"))
  26.          (ntycon? (cadr args))
  27.          (eq? (ntycon-tycon (cadr args)) (core-symbol "IOResult_")))
  28.         (print-io-tycon (car (ntycon-args (cadr args))) xp)
  29.         (print-general-tycon tycon args object xp)))))
  30.  
  31. (define (print-io-tycon ty xp)
  32.   (with-ast-block (xp)
  33.     (write-string "IO" xp)
  34.     (write-whitespace xp)
  35.     (write-atype ty xp)))
  36.  
  37. (define-ast-printer gtype (object xp)
  38.   (let ((var 0)
  39.     (res '()))
  40.     (dolist (classes (gtype-context object))
  41.        (let ((v (gtyvar->symbol var)))
  42.      (dolist (class classes)
  43.         (push (**context (**class/def class) v) res)))
  44.        (incf var))
  45.     (write-contexts (reverse res) xp)
  46.     (write (gtype-type object) xp)))
  47.           
  48. (define-ast-printer gtyvar (object xp)
  49.   (write-string (symbol->string (gtyvar->symbol (gtyvar-varnum object))) xp))
  50.  
  51. (define (gtyvar->symbol n)
  52.   (cond ((< n 26)
  53.      (list-ref '(|a| |b| |c| |d| |e| |f| |g|
  54.              |h| |i| |j| |k| |l| |m| |n|
  55.              |o| |p| |q| |r| |s| |t| |u|
  56.              |v| |w| |x| |y| |z|)
  57.            n))
  58.     (else
  59.      (string->symbol (format '#f "g~A" (- n 25))))))
  60.  
  61. (define-ast-printer recursive-type (object xp)
  62.   (write (recursive-type-type object) xp))
  63.  
  64. (define *printed-tyvars* '())
  65.  
  66. (define (tyvar->number tyvar)
  67.   (tyvar->number-1 tyvar (dynamic *printed-tyvars*) 1))
  68.  
  69. (define (tyvar->number-1 tyvar vars n)
  70.   (cond ((null? vars)
  71.      (setf (dynamic *printed-tyvars*)
  72.            (nconc (dynamic *printed-tyvars*) (list tyvar)))
  73.      n)
  74.     ((eq? tyvar (car vars))
  75.      n)
  76.     (else
  77.      (tyvar->number-1 tyvar (cdr vars) (1+ n)))))
  78.  
  79.  
  80.